home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / link / pmaxsuspend.t < prev    next >
Text File  |  1990-04-10  |  12KB  |  356 lines
  1. (herald pamxsuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (set-up-the-slink)
  6.   (modify (+area-frontier (lstate-impure *lstate*))
  7.           (lambda (x) (fx+ (fx+ x %%slink-size) %%stack-size)))
  8.   (let ((null 
  9.          (object nil
  10.            ((heap-stored self) (lstate-impure *lstate*))
  11.            ((heap-offset self) (fx+ %%stack-size tag/pair))
  12.            ((write-descriptor self stream)
  13.             (write-data stream (fx+ %%stack-size tag/pair)))
  14.            ((write-store self stream)
  15.         (do ((i 0 (fx+ i 4)))
  16.         ((fx= i %%stack-size))
  17.           (write-int stream 0))
  18.             (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  19.               (do ((i 0 (fx+ i 4)))
  20.                   ((fx= i pi)
  21.                    (write-int stream 0)
  22.                    (write-int stream (+area-frontier (lstate-pure *lstate*)))
  23.                    (write-data stream %%stack-size)
  24.                    (write-data stream (+area-frontier (lstate-impure *lstate*)))
  25.                    (write-int stream (fx-ashl (fx+ (gc-stamp) 1) 2))
  26.                    (do ((i (fx+ i 20) (fx+ i 4)))
  27.                        ((fx= i %%slink-size))
  28.                      (write-int stream 0)))
  29.                 (write-int stream 0)))))))
  30.     (set (lstate-null *lstate*) null)
  31.     (push (+area-objects (lstate-impure *lstate*)) null)
  32.     (text-relocation (fx+ %%stack-size
  33.               (fx+ slink/initial-pure-memory-begin 3)))
  34.     (text-relocation (fx+ %%stack-size (fx+ slink/initial-pure-memory-end 3)))
  35.     (data-relocation (fx+ %%stack-size
  36.               (fx+ slink/initial-impure-memory-begin 3)))
  37.     (data-relocation (fx+ %%stack-size (fx+ slink/initial-impure-memory-end 3)))
  38.     null))
  39.  
  40. (define (suspend obj out-spec x?)
  41.   (set (experimental?) x?)
  42.   (really-suspend obj out-spec 'o))
  43.  
  44.  
  45. (define-constant RELOC-SIZE 8)
  46. (define-constant MAGIC #x162)
  47. (define-constant TEXT-SYM 1)
  48. (define-constant DATA-SYM 3)
  49.  
  50. (lset reloc-length 0)
  51. (lset pure-size 0)
  52.  
  53.  
  54. (define (vgc-foreign foreign)
  55.   (let* ((heap (lstate-impure *lstate*))
  56.          (addr (+area-frontier heap))
  57.          (name (foreign-name foreign))
  58.          (desc (object nil
  59.                  ((heap-stored self) (lstate-impure *lstate*))
  60.                  ((heap-offset self) addr)
  61.                  ((write-descriptor self stream)
  62.                   (write-data stream (fx+ addr tag/extend)))
  63.                  ((write-store self stream)
  64.                   (write-int stream header/foreign)
  65.                   (write-slot name stream)
  66.                   (write-int stream 0)))))
  67.     (set (+area-frontier heap) (fx+ addr 12))
  68.     (push (+area-objects heap) desc)
  69.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  70.     (generate-slot-relocation name (fx+ addr 4))
  71.     (cymbal-thunk (symbol->string name)  0)
  72.     (reloc-thunk (fx+ addr 8) 
  73.                  (lstate-symbol-count *lstate*)
  74.          #x90)
  75.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  76.     desc))
  77.  
  78.  
  79. (define (generate-slot-relocation obj slot-address)
  80.   (cond ((or (fixnum? obj) (immediate? obj)))
  81.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  82.          (reloc-thunk slot-address DATA-SYM #x10))
  83.         (else
  84.          (reloc-thunk slot-address TEXT-SYM #x10))))
  85.  
  86. (define (text-relocation addr)
  87.   (reloc-thunk addr TEXT-SYM #x10))
  88.  
  89. (define (data-relocation addr)
  90.   (reloc-thunk addr DATA-SYM #x10))
  91.  
  92. (define (reloc-thunk address lw hb)
  93.   (push (lstate-data-reloc *lstate*)
  94.         (cons address (cons lw hb))))
  95.             
  96. (lset the-string-table nil)
  97.                          
  98. (define (write-slot obj stream)
  99.   (cond ((fixnum? obj)
  100.          (write-fixnum stream obj))
  101.         ((immediate? obj)
  102.          (write-immediate stream obj))
  103.         ((null? obj)
  104.          (write-descriptor (lstate-null *lstate*) stream))
  105.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  106.          => (lambda (desc) (write-descriptor desc stream)))
  107.         (else
  108.          (write-descriptor (lstate-null *lstate*) stream))))
  109.  
  110.  
  111.  
  112. (define-integrable (write-data stream int)
  113.   (write-int stream (fx+ pure-size int)))
  114.  
  115. (define (write-immediate stream imm)
  116.   (let ((int (descriptor->fixnum imm)))
  117.     (write-half stream (fx+ (fixnum-ashl int 2) 1))
  118.     (write-half stream (fixnum-ashr int 14))))
  119.  
  120.  
  121. (define (write-scratch stream obj i)
  122.   (let ((offset (fixnum-ashl i 2)))
  123.     (write-half stream (mref-16-u obj offset))
  124.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  125.  
  126. (define (write-int stream int)
  127.   (write-half stream int)
  128.   (let ((int (fixnum-ashr int 16)))
  129.     (write-half stream int)))
  130.  
  131. (define (write-half stream int)
  132.   (vm-write-byte stream int)
  133.   (let ((int (fixnum-ashr int 8)))
  134.     (vm-write-byte stream int)))
  135.  
  136. (define (write-fixnum stream fixnum)
  137.   (write-half stream (fixnum-ashl fixnum 2))
  138.   (write-half stream (fixnum-ashr fixnum 14)))
  139.  
  140. (define (cymbal-thunk stryng value)
  141.  (push (lstate-symbols *lstate*)
  142.   (object (lambda (stream)
  143.         (write-int stream 0)
  144.         (write-int stream (table-entry the-string-table stryng))
  145.             (cond ((fx= value 0)            ; undefined external (foreign)
  146.            (write-int stream 0)
  147.            (write-half stream #xf181))
  148.           (else
  149.            (write-descriptor value stream)
  150.            (write-half stream #xf081)))
  151.         (write-half stream #xffff))
  152.           ((cymbal-thunk.stryng self) stryng))))
  153.  
  154. (define-operation (cymbal-thunk.stryng thunk))
  155.  
  156. (define (make-global-cymbal proc name)
  157.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  158.        => (lambda (desc)                                
  159.             (cymbal-thunk (string-downcase! (symbol->string name))
  160.                           desc)
  161.             (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))))
  162.         (else
  163.          (error "~s not defined" name))))
  164.  
  165. (define (write-link-file stream)
  166.   (make-global-cymbal big_bang 'big_bang)
  167.   (make-global-cymbal interrupt_dispatcher 'interrupt_dispatcher)
  168.   (set reloc-length (length (lstate-data-reloc *lstate*)))
  169.   (modify (lstate-symbols *lstate*) reverse!)
  170.   (pad-area (lstate-pure *lstate*))
  171.   (pad-area (lstate-impure *lstate*))
  172.   (set pure-size (+area-frontier (lstate-pure *lstate*)))
  173.   (write-header     stream)
  174.   (write-aouthdr stream)
  175.   (write-text-section-header stream)
  176.   (write-data-section-header stream)
  177.   (write-area       stream (lstate-pure *lstate*))
  178.   (write-area       stream (lstate-impure *lstate*))
  179.   (write-relocation stream)
  180.   (receive (i aligned-i) (make-stryng-table)
  181.     (write-cymbal-table-header stream aligned-i)
  182.     (write-hack-local-symbol stream)
  183.     (write-hack-local-string stream)
  184.     (write-stryng-table stream (fx- aligned-i i)))
  185.   (write-hack-file-descriptor stream)
  186.   (write-cymbal-table stream))
  187.  
  188. (define (write-header stream)
  189.     (write-half stream MAGIC)                 ;magic number
  190.     (write-half stream 2)                     ; # of sections
  191.     (write-int stream 0)                      ; time and date 
  192.     (write-int stream (cymbal-table-offset))
  193.     (write-int stream #x60)        ;size of symbol header
  194.     (write-half stream #x38)                      ; size of a.out header
  195.     (write-half stream 0))        ;flags
  196.  
  197. (define (write-aouthdr stream)
  198.   (write-half stream #x107)        ;magic
  199.   (write-half stream #x11f)        ;version stamp
  200.   (write-int stream (text-size))    ;text size
  201.   (write-int stream (data-size))    ;data size
  202.   (write-int stream 0)            ;bss size
  203.   (write-int stream 0)            ;entry
  204.   (write-int stream 0)            ;text base
  205.   (write-int stream (text-size))    ;data base
  206.   (write-int stream (+ (text-size) (data-size))) ;bss base
  207.   (write-int stream 0)            ;register mask
  208.   (write-int stream 0)            ;cp mask [4]
  209.   (write-int stream 0)
  210.   (write-int stream 0)
  211.   (write-int stream 0)
  212.   (write-int stream #x8010))        ;gp value ???
  213.  
  214.  
  215. (define (write-text-section-header stream)   
  216.   (write-string stream ".text")
  217.   (vm-write-byte stream 0)
  218.   (vm-write-byte stream #x20)
  219.   (vm-write-byte stream #x20)
  220.   (write-int stream 0)      ; phys addr
  221.   (write-int stream 0)      ; virtual addr
  222.   (write-int stream (text-size))    
  223.   (write-int stream (headers-size))    ;offset in file
  224.   (write-int stream 0)      ; no reloc
  225.   (write-int stream 0)      ; no gp table
  226.   (write-int stream 0)      
  227.   (write-int stream #x20))
  228.   
  229. (define (write-data-section-header stream)   
  230.   (write-string stream ".data")
  231.   (vm-write-byte stream 0)
  232.   (vm-write-byte stream #x20)
  233.   (vm-write-byte stream #x20)
  234.   (write-int stream (text-size))      ; phys addr
  235.   (write-int stream (text-size))      ; virtual addr
  236.   (write-int stream (data-size))    
  237.   (write-int stream (+ (text-size) (headers-size)))    ;offset in file
  238.   (write-int stream (+ (headers-size) (text-size) (data-size)))    ;  reloc
  239.   (write-int stream 0)      ; no gp table
  240.   (write-half  stream #xffff)        ;reloc overflow
  241.   (write-half stream 0)            ;no gp table
  242.   (write-half stream #x40)    ;data flag
  243.   (write-half stream #x2000))    ; reloc overflow
  244.  
  245. (define (headers-size) (fx* 39 4))
  246. (define (text-size) (+area-frontier (lstate-pure *lstate*)))
  247. (define (data-size) (+area-frontier (lstate-impure *lstate*)))
  248.  
  249. (define (cymbal-table-offset)
  250.   (+ (headers-size) (text-size) (data-size)
  251.      (* RELOC-SIZE (+ reloc-length 1)))) ;hack number of reloc overflow
  252.  
  253. (define (write-area stream area)
  254.   (walk (lambda (x) (write-store x stream))
  255.         (reverse! (+area-objects area))))
  256.  
  257.  
  258. (define (write-relocation stream)
  259.   (write-int stream (fx+ reloc-length 1))    ;number of relocs
  260.   (write-int stream 0)            ;R_ABS
  261.   (walk (lambda (item)
  262.       (destructure (((addr . (lw .  hb)) item))
  263.         (write-data stream (car item))
  264.         (write-half stream lw)
  265.         (vm-write-byte stream 0)
  266.         (vm-write-byte stream hb)))
  267.         (sort-list! (lstate-data-reloc *lstate*)
  268.                     (lambda (x y)      
  269.                        (fx< (car x) (car y))))))
  270.  
  271.  
  272. (define (write-map-entry stream name value) nil)
  273.  
  274. (define (write-cymbal-table-header stream string-table-size)
  275.   (write-half stream #x7009)        ;magic
  276.   (write-half stream #x11f)        ;vstamp
  277.   (write-long-zeros stream 7)
  278.   (write-int stream 2)            ;number of local symbols
  279.   (write-int stream (+ (cymbal-table-offset) #x60))
  280.   (write-long-zeros stream 4)
  281.   (write-int stream 8)            ;max index in local strings
  282.   (write-int stream (+ (cymbal-table-offset) #x60 24))
  283.   (write-int stream string-table-size)    ;max string-index
  284.   (write-int stream (+ (cymbal-table-offset) #x60 8 24)) ;string table begin
  285.   (write-int stream 1)            ;fd entries
  286.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size))
  287.   (write-long-zeros stream 2)
  288.   (write-int stream (lstate-symbol-count *lstate*)) ;max symbol index
  289.   (write-int stream (+ (cymbal-table-offset) #x60 8 24 string-table-size 72)))
  290.  
  291. (define (write-hack-local-symbol stream)
  292.   (write-int stream 1)
  293.   (write-int stream 0)
  294.   (write-int stream #x204b)
  295.   (write-int stream 1)
  296.   (write-int stream 0)
  297.   (write-int stream #x48))
  298.  
  299.  
  300. (define (write-hack-local-string stream)
  301.   (vm-write-byte stream 0)
  302.   (write-string stream "foo.s")
  303.   (vm-write-byte stream 0)
  304.   (vm-write-byte stream 0))
  305.  
  306. (define (write-hack-file-descriptor stream)
  307.   (walk (lambda (x) (write-int stream x))
  308.     '(0 1 0 7 0 2 0 0 0 0 0 0 0 0 0))
  309.   (write-int stream #x223)
  310.   (write-int stream 0)
  311.   (write-int stream 0))
  312.  
  313.  
  314. (define (write-long-zeros stream n)
  315.   (do ((i n (fx- i 1)))
  316.       ((fx= i 0))
  317.     (write-int stream 0)))
  318.  
  319. (define (write-cymbal-table stream)
  320.   (walk (lambda (cym) (cym stream)) (lstate-symbols *lstate*)))
  321.  
  322. (define (make-stryng-table)
  323.   (set the-string-table (make-string-table 'stryngs))
  324.   (iterate loop ((i 0) (cyms (lstate-symbols *lstate*)))
  325.       (cond ((null? cyms) (return i (align i 2)))
  326.             (else
  327.              (let* ((string (cymbal-thunk.stryng (car cyms)))
  328.                     (len (string-length string)))
  329.            (set (table-entry the-string-table string) i)
  330.            (loop (fx+ i (fx+ len 1)) (cdr cyms)))))))
  331.                                                        
  332.  
  333. (define (write-stryng-table stream extra)
  334.   (walk (lambda (cym)
  335.       (write-string stream (cymbal-thunk.stryng cym))
  336.       (vm-write-byte stream 0))
  337.     (lstate-symbols *lstate*))
  338.   (do ((extra extra (fx- extra 1)))
  339.       ((fx= extra 0))
  340.     (vm-write-byte stream 0)))
  341.  
  342.  
  343. (define (pad-area area)
  344.   (let ((rem (fixnum-remainder (+area-frontier area) 16)))
  345.     (cond ((fxn= rem 0)
  346.        (modify (+area-frontier area)
  347.            (lambda (x) (fx+ x (fx- 16 rem))))
  348.        (do ((i (fx- 16 rem) (fx- i 4)))
  349.            ((fx= i 0))
  350.          (push (+area-objects area)
  351.            (object nil
  352.              ((write-store self stream)
  353.               (write-int stream 0)))))))))
  354.  
  355.  
  356.